home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / overload.pm < prev    next >
Text File  |  2008-07-24  |  4KB  |  178 lines
  1. package overload;
  2.  
  3. our $VERSION = '1.06';
  4.  
  5. sub nil {}
  6.  
  7. sub OVERLOAD {
  8.   $package = shift;
  9.   my %arg = @_;
  10.   my ($sub, $fb);
  11.   $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
  12.   *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
  13.   for (keys %arg) {
  14.     if ($_ eq 'fallback') {
  15.       $fb = $arg{$_};
  16.     } else {
  17.       $sub = $arg{$_};
  18.       if (not ref $sub and $sub !~ /::/) {
  19.     $ {$package . "::(" . $_} = $sub;
  20.     $sub = \&nil;
  21.       }
  22.       #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
  23.       *{$package . "::(" . $_} = \&{ $sub };
  24.     }
  25.   }
  26.   ${$package . "::()"} = $fb; # Make it findable too (fallback only).
  27. }
  28.  
  29. sub import {
  30.   $package = (caller())[0];
  31.   # *{$package . "::OVERLOAD"} = \&OVERLOAD;
  32.   shift;
  33.   $package->overload::OVERLOAD(@_);
  34. }
  35.  
  36. sub unimport {
  37.   $package = (caller())[0];
  38.   ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
  39.   shift;
  40.   for (@_) {
  41.     if ($_ eq 'fallback') {
  42.       undef $ {$package . "::()"};
  43.     } else {
  44.       delete $ {$package . "::"}{"(" . $_};
  45.     }
  46.   }
  47. }
  48.  
  49. sub Overloaded {
  50.   my $package = shift;
  51.   $package = ref $package if ref $package;
  52.   $package->can('()');
  53. }
  54.  
  55. sub ov_method {
  56.   my $globref = shift;
  57.   return undef unless $globref;
  58.   my $sub = \&{*$globref};
  59.   return $sub if $sub ne \&nil;
  60.   return shift->can($ {*$globref});
  61. }
  62.  
  63. sub OverloadedStringify {
  64.   my $package = shift;
  65.   $package = ref $package if ref $package;
  66.   #$package->can('(""')
  67.   ov_method mycan($package, '(""'), $package
  68.     or ov_method mycan($package, '(0+'), $package
  69.     or ov_method mycan($package, '(bool'), $package
  70.     or ov_method mycan($package, '(nomethod'), $package;
  71. }
  72.  
  73. sub Method {
  74.   my $package = shift;
  75.   if(ref $package) {
  76.     local $@;
  77.     local $!;
  78.     require Scalar::Util;
  79.     $package = Scalar::Util::blessed($package);
  80.     return undef if !defined $package;
  81.   }
  82.   #my $meth = $package->can('(' . shift);
  83.   ov_method mycan($package, '(' . shift), $package;
  84.   #return $meth if $meth ne \&nil;
  85.   #return $ {*{$meth}};
  86. }
  87.  
  88. sub AddrRef {
  89.   my $package = ref $_[0];
  90.   return "$_[0]" unless $package;
  91.  
  92.   local $@;
  93.   local $!;
  94.   require Scalar::Util;
  95.   my $class = Scalar::Util::blessed($_[0]);
  96.   my $class_prefix = defined($class) ? "$class=" : "";
  97.   my $type = Scalar::Util::reftype($_[0]);
  98.   my $addr = Scalar::Util::refaddr($_[0]);
  99.   return sprintf("$class_prefix$type(0x%x)", $addr);
  100. }
  101.  
  102. *StrVal = *AddrRef;
  103.  
  104. sub mycan {                # Real can would leave stubs.
  105.   my ($package, $meth) = @_;
  106.  
  107.   my $mro = mro::get_linear_isa($package);
  108.   foreach my $p (@$mro) {
  109.     my $fqmeth = $p . q{::} . $meth;
  110.     return \*{$fqmeth} if defined &{$fqmeth};
  111.   }
  112.  
  113.   return undef;
  114. }
  115.  
  116. %constants = (
  117.           'integer'      =>  0x1000, # HINT_NEW_INTEGER
  118.           'float'      =>  0x2000, # HINT_NEW_FLOAT
  119.           'binary'      =>  0x4000, # HINT_NEW_BINARY
  120.           'q'      =>  0x8000, # HINT_NEW_STRING
  121.           'qr'      => 0x10000, # HINT_NEW_RE
  122.          );
  123.  
  124. %ops = ( with_assign      => "+ - * / % ** << >> x .",
  125.      assign          => "+= -= *= /= %= **= <<= >>= x= .=",
  126.      num_comparison      => "< <= >  >= == !=",
  127.      '3way_comparison'=> "<=> cmp",
  128.      str_comparison      => "lt le gt ge eq ne",
  129.      binary          => '& &= | |= ^ ^=',
  130.      unary          => "neg ! ~",
  131.      mutators      => '++ --',
  132.      func          => "atan2 cos sin exp abs log sqrt int",
  133.      conversion      => 'bool "" 0+',
  134.      iterators      => '<>',
  135.      dereferencing      => '${} @{} %{} &{} *{}',
  136.      special      => 'nomethod fallback =');
  137.  
  138. use warnings::register;
  139. sub constant {
  140.   # Arguments: what, sub
  141.   while (@_) {
  142.     if (@_ == 1) {
  143.         warnings::warnif ("Odd number of arguments for overload::constant");
  144.         last;
  145.     }
  146.     elsif (!exists $constants {$_ [0]}) {
  147.         warnings::warnif ("`$_[0]' is not an overloadable type");
  148.     }
  149.     elsif (!ref $_ [1] || "$_[1]" !~ /CODE\(0x[\da-f]+\)$/) {
  150.         # Can't use C<ref $_[1] eq "CODE"> above as code references can be
  151.         # blessed, and C<ref> would return the package the ref is blessed into.
  152.         if (warnings::enabled) {
  153.             $_ [1] = "undef" unless defined $_ [1];
  154.             warnings::warn ("`$_[1]' is not a code reference");
  155.         }
  156.     }
  157.     else {
  158.         $^H{$_[0]} = $_[1];
  159.         $^H |= $constants{$_[0]};
  160.     }
  161.     shift, shift;
  162.   }
  163. }
  164.  
  165. sub remove_constant {
  166.   # Arguments: what, sub
  167.   while (@_) {
  168.     delete $^H{$_[0]};
  169.     $^H &= ~ $constants{$_[0]};
  170.     shift, shift;
  171.   }
  172. }
  173.  
  174. 1;
  175.  
  176. __END__
  177.  
  178.